home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 051-060 / amok59 / menu / menu.mod < prev    next >
Text File  |  1993-11-04  |  10KB  |  422 lines
  1. MODULE Menu;
  2.  
  3.  
  4. (*------  importlist:  ------*)
  5.  
  6.  
  7. IMPORT sys := SYSTEM,
  8.        g   := Graphics,
  9.        str := Strings,
  10.        I   := Intuition;
  11.  
  12.  
  13. (*------  Globals:  ------*)
  14.  
  15.  
  16. VAR
  17.   oom*: PROCEDURE();              (* Wird bei Speichermangel aufgerufen, sollte entweder
  18.                                      versuchen, Speicher freizugeben und zurückkehren, oder
  19.                                      das Programm abbrechen. *)
  20.  
  21.   FirstMenu,LastMenu: I.MenuPtr;  (* Erster und letzter Menüstreifen *)
  22.   LastItem: I.MenuItemPtr;        (* Zuletzt erzeugtes Item          *)
  23.  
  24.   leftBase: INTEGER;    (* linke Kante des Menütitels  *)
  25.   height: INTEGER;      (* Höhe des Menüs              *)
  26.   ItemWidth: INTEGER;   (* Breite des breitesten Itemtextes   *)
  27.   ItemWidth2: INTEGER;  (* Breite des breitesten Itemtextes 2 *)
  28.   rp: g.RastPortPtr;    (* RastPort des Screens        *)
  29.   screen: I.ScreenPtr;  (* Der Screen selbst           *)
  30.   commandWidth: INTEGER;(* Breite des Breitetsten Command-Keys *)
  31.  
  32.  
  33. (*------  Menü Starten Menue:  ------*)
  34.  
  35.  
  36. PROCEDURE StartMenu*(win: I.WindowPtr);
  37. (* Diese Prozedur muß vor allen anderen Prozeduren dieses Moduls aufgerufen werden. *)
  38.  
  39. BEGIN
  40.   leftBase := 0;
  41.   FirstMenu := NIL;
  42.   LastMenu := NIL;
  43.   screen := win.wScreen;
  44.   rp := sys.ADR(screen.rastPort);
  45. END StartMenu;
  46.  
  47.  
  48. (*------  EndStrip:  ------*)
  49.  
  50.  
  51. PROCEDURE EndStrip;
  52. (* Interne Prozedur, beendet aktuelle Menuleiste und setzt Breite der Items *)
  53.  
  54. VAR
  55.   it: I.IntuiTextPtr;
  56.   im: I.ImagePtr;
  57.   top, left,height,width: INTEGER;
  58.  
  59. BEGIN
  60.   INC(ItemWidth,g.TextLength(rp,"M",1));
  61.   INC(commandWidth,I.commWidth);
  62.   IF commandWidth>ItemWidth2 THEN ItemWidth2 := commandWidth END;
  63.   LastItem := LastMenu.firstItem;
  64.   left := 0; height := 0; width := ItemWidth + ItemWidth2 + 2;
  65.   WHILE LastItem#NIL DO
  66.     LastItem.width := width;
  67.     height := LastItem.topEdge + LastItem.height;
  68.     INC(LastItem.leftEdge,left);
  69.     IF I.itemText IN LastItem.flags THEN
  70.       it := LastItem.itemFill;
  71.       it := it.nextText;
  72.       IF it#NIL THEN
  73.         it.leftEdge := LastItem.width-2;
  74.         DEC(it.leftEdge,g.TextLength(rp,it.iText^,str.Length(it.iText^)));
  75.       END;
  76.     ELSE
  77.       im := LastItem.itemFill;
  78.       im.width := ItemWidth+ItemWidth2;
  79.     END;
  80.     LastItem := LastItem.nextItem;
  81.   END;
  82.   IF height + screen.barHeight + 4 > screen.height THEN
  83.     LastItem := LastMenu.firstItem;
  84.     WHILE (LastItem#NIL) AND (LastItem.topEdge + LastItem.height < height DIV 2) DO
  85.       LastItem := LastItem.nextItem;
  86.     END;
  87.     IF LastItem#NIL THEN
  88.       left := height - LastItem.topEdge + LastItem.height;
  89.       IF left - (LastItem.topEdge + LastItem.height) >= LastItem.height THEN
  90.         LastItem := LastItem.nextItem;
  91.       END;
  92.       IF LastItem#NIL THEN
  93.         top := LastItem.topEdge;
  94.         left := width + 4; INC(width,left);
  95.         WHILE LastItem#NIL DO
  96.           DEC(LastItem.topEdge,top);
  97.           INC(LastItem.leftEdge,left);
  98.           LastItem := LastItem.nextItem;
  99.         END;
  100.       END;
  101.     END;
  102.   END;
  103.   IF width + LastMenu.leftEdge + 16 > screen.width THEN
  104.     DEC(width,screen.width - LastMenu.leftEdge - 16);
  105.     IF width > LastMenu.leftEdge THEN width := LastMenu.leftEdge END;
  106.     LastItem := LastMenu.firstItem;
  107.     WHILE (LastItem#NIL) DO
  108.       DEC(LastItem.leftEdge,width);
  109.       LastItem := LastItem.nextItem;
  110.     END;
  111.   END;
  112. END EndStrip;
  113.  
  114.  
  115. (*------  NewMenu:  ------*)
  116.  
  117.  
  118. PROCEDURE NewMenu*(name: ARRAY OF CHAR); (* $CopyArrays- *)
  119. (* Startet neue Menüleiste. Parameter ist der Name dieses Menüs.
  120.  * NewMenu muß aufgerufen werden, bevor eine der Itemprozeduren
  121.  * (s.u.) aufgerufen wird.
  122.  *)
  123.  
  124. VAR
  125.   m: I.MenuPtr;
  126.  
  127. BEGIN
  128.   IF LastMenu#NIL THEN EndStrip END;
  129.   LOOP
  130.     NEW(m); IF m#NIL THEN EXIT END;
  131.     oom;
  132.   END;
  133.   IF FirstMenu=NIL THEN FirstMenu         := m;
  134.                    ELSE LastMenu.nextMenu := m END;
  135.   LastMenu := m;
  136.   m.leftEdge  := leftBase;
  137.   m.topEdge   := 0;
  138.   m.width     := g.TextLength(rp,name,str.Length(name))+12;
  139.   INC(leftBase,m.width+10);
  140.   m.height    := 0;
  141.   m.flags     := {I.miDrawn,I.menuEnabled};
  142.   m.menuName  := sys.ADR(name);
  143.   m.firstItem := NIL;
  144.   LastItem := NIL;
  145.   ItemWidth := 0;
  146.   ItemWidth2 := 0;
  147.   height := 0;
  148.   commandWidth := 0;
  149. END NewMenu;
  150.  
  151.  
  152. (*------  Item:  ------*)
  153.  
  154.  
  155. PROCEDURE Item(name: ARRAY OF CHAR;
  156.                name2: ARRAY OF CHAR;
  157.                com: CHAR;
  158.                checkmark,checked: BOOLEAN); (* $CopyArrays- *)
  159. (* Interne Prozedur zum Erzeugen von Menuitems *)
  160.  
  161.  
  162. VAR
  163.   t: I.MenuItemPtr;
  164.   it,it2: I.IntuiTextPtr;
  165.   w: INTEGER;
  166.   comstr: ARRAY 1 OF CHAR;
  167.  
  168. BEGIN
  169.   LOOP
  170.     NEW(t);
  171.     IF t#NIL THEN EXIT END;
  172.     oom;
  173.   END;
  174.   LOOP
  175.     NEW(it);
  176.     IF it#NIL THEN EXIT END;
  177.     oom;
  178.   END;
  179.   IF LastItem=NIL THEN LastMenu.firstItem := t
  180.                   ELSE LastItem.nextItem  := t END;
  181.   LastItem := t;
  182.   t.leftEdge  := 2;
  183.   t.topEdge   := height;
  184.   w := g.TextLength(rp,name,str.Length(name));
  185.   IF checkmark THEN INC(w,I.checkWidth) END;
  186.   IF w>ItemWidth THEN ItemWidth := w END;
  187.   t.height    := rp.font.ySize+2;
  188.   INC(height,t.height + t.height DIV 10);
  189.   t.flags     := {I.itemText,I.itemEnabled,I.highComp};
  190.   IF checkmark THEN
  191.     t.flags := t.flags + {I.checkIt,I.menuToggle};
  192.     IF checked THEN INCL(t.flags,I.checked) END;
  193.   END;
  194.   IF com#0X THEN
  195.     INCL(t.flags,I.commSeq);
  196.     comstr[0] := com;
  197.     w := g.TextLength(rp,comstr,1);
  198.     IF w>commandWidth THEN commandWidth := w END;
  199.   END;
  200.   t.mutualExclude := LONGSET{};
  201.   t.itemFill  := it;
  202.   t.selectFill:= NIL;
  203.   t.command   := com; t.subItem  := NIL;
  204.   it.frontPen := screen.detailPen; it.backPen := screen.blockPen;
  205.   it.drawMode := g.jam2;
  206.   it.iTextFont:= NIL;
  207.   it.topEdge  := 1;
  208.   it.leftEdge := 2;
  209.   IF checkmark THEN INC(it.leftEdge,I.checkWidth) END;
  210.   it.iText    := sys.ADR(name);
  211.   IF name2[0]#0X THEN
  212.     LOOP
  213.       NEW(it2);
  214.       IF it2#NIL THEN EXIT END;
  215.       oom;
  216.     END;
  217.     it2^ := it^;
  218.     it2.iText := sys.ADR(name2);
  219.     it.nextText := it2;
  220.     w := g.TextLength(rp,name2,str.Length(name2));
  221.     IF w>ItemWidth2 THEN ItemWidth2 := w END;
  222.   END;
  223. END Item;
  224.  
  225.  
  226. (*------  NewItem:  ------*)
  227.  
  228.  
  229. PROCEDURE NewItem*(name: ARRAY OF CHAR;
  230.                    com: CHAR);                  (* $CopyArrays- *)
  231.  
  232. (* erzeugt neues Menuitem mit Namen name und Tastatur-Shortcut Amiga+com.
  233.  * Ist com=0X hat dieser Menüpunkt keine Tastaturabkürzung
  234.  *)
  235.  
  236. BEGIN
  237.   Item(name,"",com,FALSE,FALSE);
  238. END NewItem;
  239.  
  240.  
  241. (*------  NewItem2:  ------*)
  242.  
  243.  
  244. PROCEDURE NewItem2*(name: ARRAY OF CHAR;
  245.                     name2: ARRAY OF CHAR);      (* $CopyArrays- *)
  246.  
  247. (* erzeugt neues Menuitem mit Namen name und name2. name2 wird dabei
  248.  * rechtsbündig ins Menü eingefügt. Es sollte vor allem für Tastatur-
  249.  * abkürzungen wie '^Q' verwendet werden.
  250.  *)
  251.  
  252. BEGIN
  253.   Item(name,name2,0X,FALSE,FALSE);
  254. END NewItem2;
  255.  
  256.  
  257. (*------  NewItemChecked:  ------*)
  258.  
  259.  
  260. PROCEDURE NewItemChecked*(name: ARRAY OF CHAR;
  261.                           com: CHAR;
  262.                           checked: BOOLEAN);    (* $CopyArrays- *)
  263.  
  264. (* erzeugt neues Menuitem mit Namen name und Tastatur-Shortcut Amiga+com.
  265.  * Ist com=0X hat dieser Menüpunkt keine Tastaturabkürzung. Dieses Menü
  266.  * bekommt ein Häkchen. Ist checked=TRUE, wird dieses Häkchen gleich
  267.  * gesetzt.
  268.  *)
  269.  
  270. BEGIN
  271.   Item(name,"",com,TRUE,checked);
  272. END NewItemChecked;
  273.  
  274.  
  275. (*------  NewItemChecked:  ------*)
  276.  
  277.  
  278. PROCEDURE NewItem2Checked*(name: ARRAY OF CHAR;
  279.                            name2: ARRAY OF CHAR;
  280.                            checked: BOOLEAN);    (* $CopyArrays- *)
  281.  
  282. (* erzeugt neues Menuitem mit Namen name und name2. name2 wird dabei
  283.  * rechtsbündig ins Menü eingefügt. Es sollte vor allem für Tastatur-
  284.  * abkürzungen wie '^Q' * verwendet werden. Dieses Menü bekommt ein
  285.  * Häkchen. Ist checked=TRUE, wird dieses Häkchen gleich gesetzt.
  286.  *)
  287.  
  288. BEGIN
  289.   Item(name,name2,0X,TRUE,checked);
  290. END NewItem2Checked;
  291.  
  292.  
  293. (*------  Seperator:  ------*)
  294.  
  295.  
  296. PROCEDURE Seperator*;
  297. (* Erzeugt Linie *)
  298.  
  299.  
  300. VAR
  301.   t: I.MenuItemPtr;
  302.   im: I.ImagePtr;
  303.   comstr: ARRAY 1 OF CHAR;
  304.  
  305. BEGIN
  306.   LOOP
  307.     NEW(t);
  308.     IF t#NIL THEN EXIT END;
  309.     oom;
  310.   END;
  311.   LOOP
  312.     NEW(im);
  313.     IF im#NIL THEN EXIT END;
  314.     oom;
  315.   END;
  316.   IF LastItem=NIL THEN LastMenu.firstItem := t
  317.                   ELSE LastItem.nextItem  := t END;
  318.   LastItem := t;
  319.   t.leftEdge  := 2;
  320.   t.topEdge   := height;
  321.   t.height    := 5;
  322.   INC(height,5);
  323.   t.flags     := I.highNone;
  324.   t.mutualExclude := LONGSET{};
  325.   t.itemFill  := im;
  326.   t.selectFill:= NIL;
  327.   t.command   := 0X;
  328.   t.subItem   := NIL;
  329.   im.leftEdge := 1;
  330.   im.topEdge  := 1;
  331.   im.width    := 0;
  332.   im.height   := 2;
  333.   im.depth    := 0;
  334.   im.imageData:= NIL;
  335.   im.planePick:= SHORTSET{};
  336.   im.planeOnOff:= SHORTSET{};
  337.   im.nextImage:= NIL;
  338. END Seperator;
  339.  
  340.  
  341. (*------  EndMenu:  ------*)
  342.  
  343.  
  344. PROCEDURE EndMenu*(): I.MenuPtr;
  345.  
  346. (* Beendet das Menü und gibt einen Zeiger auf die Menüstruktur zurück. Das Ergebnis
  347.  * ist #NIL wenn NewMenu() mindestens einmal aufgerufen wurde.
  348.  *)
  349.  
  350. BEGIN
  351.   EndStrip;
  352.   RETURN FirstMenu;
  353. END EndMenu;
  354.  
  355.  
  356.  
  357.  
  358. (*------  EndMenu:  ------*)
  359.  
  360.  
  361. PROCEDURE DisposeMenu*(m: I.MenuPtr);
  362.  
  363. (* Gibt den Speicher des Menüs wieder frei: *)
  364.  
  365.   PROCEDURE DisposeText(t: I.IntuiTextPtr);
  366.   BEGIN
  367.     IF t#NIL THEN
  368.       DisposeText(t.nextText);
  369.       DISPOSE(t);
  370.     END;
  371.   END DisposeText;
  372.  
  373.   PROCEDURE DisposeImage(i: I.ImagePtr);
  374.   BEGIN
  375.     IF i#NIL THEN
  376.       DisposeImage(i.nextImage);
  377.       DISPOSE(i);
  378.     END;
  379.   END DisposeImage;
  380.  
  381.   PROCEDURE DisposeItem(i: I.MenuItemPtr);
  382.   BEGIN
  383.     IF i#NIL THEN
  384.       DisposeItem(i.nextItem);
  385.       IF I.itemText IN i.flags THEN DisposeText (i.itemFill)
  386.                                ELSE DisposeImage(i.itemFill) END;
  387.       DISPOSE(i);
  388.     END;
  389.   END DisposeItem;
  390.  
  391. BEGIN
  392.   IF m#NIL THEN
  393.     DisposeMenu(m.nextMenu);
  394.     DisposeItem(m.firstItem);
  395.     DISPOSE(m);
  396.   END;
  397. END DisposeMenu;
  398.  
  399.  
  400. (*------  OOM:  ------*)
  401.  
  402.  
  403. PROCEDURE * OOM;
  404.  
  405. (* Voreingestellte Prozedur für oom:
  406.  *)
  407.  
  408. BEGIN
  409.   HALT(20);
  410. END OOM;
  411.  
  412.  
  413. (*------  Initialisierung:  ------*)
  414.  
  415.  
  416. BEGIN
  417.  
  418.   oom := OOM;
  419.  
  420. END Menu.
  421.  
  422.